home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / xlib / interface.t < prev    next >
Text File  |  1990-06-07  |  2KB  |  78 lines
  1. (herald interface (env tsys))
  2.  
  3. (define (bytev-append . args) 
  4.   (let ((len (do ((args args (cdr args))
  5.           (len 0 (fx+ len (bytev-length (car args)))))
  6.          ((null? args) len))))
  7.     (let ((new (make-bytev len)))
  8.       (iterate loop ((args args) (i 0))
  9.     (cond ((null? args) new)
  10.           (else
  11.            (let* ((bytev (car args))
  12.               (len (bytev-length bytev)))
  13.          (do ((j 0 (fx+ j 1)))
  14.              ((fx>= j len)
  15.               (loop (cdr args) (fx+ i len)))
  16.            (set (bref new (fx+ i j)) (bref bytev j))))))))))
  17.  
  18.  
  19. (define (sub-bytev x begin end) 
  20.   (let* ((size (fx- end begin))
  21.      (new (make-bytev size)))
  22.     (do ((i 0 (fx+ i 1)))
  23.     ((fx>= i size) new)
  24.       (set (bref new i) (bref x (fx+ begin i))))))
  25.  
  26. (define-constant (c->extend x)
  27.   (gc-pair->extend (gc-pair->extend x)))
  28.  
  29. (define-constant (->extend x)
  30.   (if (fixnum? x)
  31.       (c->extend x)
  32.       x))
  33.  
  34. (define (mref-8-u x i)
  35.   (bref-8-u (->extend x) i))
  36.  
  37. (define (mref-16-u x i)
  38.   (bref-16-u (->extend x) i))
  39.  
  40. (define (mref-16-s x i)
  41.   (bref-16-s (->extend x) i))
  42.  
  43. (define (mref-integer x i)
  44.   (bref-32 (->extend x) i))
  45.  
  46.  
  47.  
  48. (define (set-mref-8-u! x i val)
  49.   (set (bref-8-u (->extend x) i) val))
  50.  
  51. (define (set-mref-16-u! x i val)
  52.   (set (bref-16-u (->extend x) i) val))
  53.  
  54. (define (set-mref-16-s! x i val)
  55.   (set (bref-16-s (->extend x) i) val))
  56.  
  57. (define (set-mref-integer! x i val)
  58.   (set (bref-32 (->extend x) i) val))
  59.  
  60. (define (mref-pointer x i)
  61.   (extend-elt (->extend x) (fixnum-ashr i 2)))
  62.  
  63. (define (set-mref-pointer! x i val)
  64.   (set (extend-elt (->extend x) (fixnum-ashr i 2)) val))
  65.  
  66. (define (bit-or . args)
  67.   (do ((args args (cdr args))
  68.        (val 0 (fixnum-logior val (car args))))
  69.       ((null? args) val)))
  70.  
  71. (define (bit-and . args)
  72.   (do ((args args (cdr args))
  73.        (val 0 (fixnum-logand val (car args))))
  74.       ((null? args) val)))
  75.  
  76. (define bit-xor fixnum-logxor)
  77. (define bit-not fixnum-lognot)
  78.